home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / list.c < prev    next >
C/C++ Source or Header  |  1992-10-09  |  8KB  |  340 lines
  1. #include "scheme.h"
  2.  
  3. Object Const_Cons (car, cdr) Object car, cdr; {
  4.     Object ret = P_Cons (car, cdr);
  5.     SETCONST(ret);
  6.     return ret;
  7. }
  8.  
  9. Object P_Cons (car, cdr) Object car, cdr; {
  10.     Object cell;
  11.     GC_Node2;
  12.  
  13. #ifdef INCREMENTAL_GC
  14.     GC_Link2 (car, cdr);
  15.     cell = Alloc_Object (sizeof (struct S_Pair), T_Pair, 0);
  16.     GC_Unlink;
  17. #else
  18.     register char *p;
  19.  
  20.     p = Hp;
  21.     ALIGN(p);
  22.     if (p + sizeof (struct S_Pair) <= Heap_End && !GC_Debug) {
  23.     Hp = p + sizeof (struct S_Pair);
  24.     SET(cell, T_Pair, (struct S_Pair *)p);
  25.     } else {
  26.     GC_Link2 (car, cdr);
  27.     cell = Alloc_Object (sizeof (struct S_Pair), T_Pair, 0);
  28.     GC_Unlink;
  29.     }
  30. #endif
  31.     Car (cell) = car;
  32.     Cdr (cell) = cdr;
  33.     return cell;
  34. }
  35.  
  36. Object P_Car (x) Object x; {
  37.     Check_Type (x, T_Pair);
  38.     return Car (x);
  39. }
  40.  
  41. Object P_Cdr (x) Object x; {
  42.     Check_Type (x, T_Pair);
  43.     return Cdr (x);
  44. }
  45.  
  46. Object Cxr (x, pat, len) Object x; register char *pat; register len; {
  47.     Object ret;
  48.  
  49.     for (ret = x, pat += len; !Nullp (ret) && len > 0; len--)
  50.     switch (*--pat) {
  51.     case 'a': ret = P_Car (ret); break;
  52.     case 'd': ret = P_Cdr (ret); break;
  53.     default: Primitive_Error ("invalid pattern");
  54.     }
  55.     return ret;
  56. }
  57.  
  58. Object P_Cddr   (x) Object x; { return Cxr (x,  "dd", 2); }
  59. Object P_Cdar   (x) Object x; { return Cxr (x,  "da", 2); }
  60. Object P_Cadr   (x) Object x; { return Cxr (x,  "ad", 2); }
  61. Object P_Caar   (x) Object x; { return Cxr (x,  "aa", 2); }
  62.  
  63. Object P_Cdddr  (x) Object x; { return Cxr (x, "ddd", 3); }
  64. Object P_Cddar  (x) Object x; { return Cxr (x, "dda", 3); }
  65. Object P_Cdadr  (x) Object x; { return Cxr (x, "dad", 3); }
  66. Object P_Cdaar  (x) Object x; { return Cxr (x, "daa", 3); }
  67. Object P_Caddr  (x) Object x; { return Cxr (x, "add", 3); }
  68. Object P_Cadar  (x) Object x; { return Cxr (x, "ada", 3); }
  69. Object P_Caadr  (x) Object x; { return Cxr (x, "aad", 3); }
  70. Object P_Caaar  (x) Object x; { return Cxr (x, "aaa", 3); }
  71.  
  72. Object P_Caaaar (x) Object x; { return Cxr (x, "aaaa", 4); }
  73. Object P_Caaadr (x) Object x; { return Cxr (x, "aaad", 4); }
  74. Object P_Caadar (x) Object x; { return Cxr (x, "aada", 4); }
  75. Object P_Caaddr (x) Object x; { return Cxr (x, "aadd", 4); }
  76. Object P_Cadaar (x) Object x; { return Cxr (x, "adaa", 4); }
  77. Object P_Cadadr (x) Object x; { return Cxr (x, "adad", 4); }
  78. Object P_Caddar (x) Object x; { return Cxr (x, "adda", 4); }
  79. Object P_Cadddr (x) Object x; { return Cxr (x, "addd", 4); }
  80. Object P_Cdaaar (x) Object x; { return Cxr (x, "daaa", 4); }
  81. Object P_Cdaadr (x) Object x; { return Cxr (x, "daad", 4); }
  82. Object P_Cdadar (x) Object x; { return Cxr (x, "dada", 4); }
  83. Object P_Cdaddr (x) Object x; { return Cxr (x, "dadd", 4); }
  84. Object P_Cddaar (x) Object x; { return Cxr (x, "ddaa", 4); }
  85. Object P_Cddadr (x) Object x; { return Cxr (x, "ddad", 4); }
  86. Object P_Cdddar (x) Object x; { return Cxr (x, "ddda", 4); }
  87. Object P_Cddddr (x) Object x; { return Cxr (x, "dddd", 4); }
  88.  
  89. Object P_Cxr (x, pat) Object x, pat; {
  90.     Check_List (x);
  91.     if (TYPE(pat) == T_Symbol)
  92.     pat = SYMBOL(pat)->name;
  93.     else if (TYPE(pat) != T_String)
  94.     Wrong_Type_Combination (pat, "string or symbol");
  95.     return Cxr (x, STRING(pat)->data, STRING(pat)->size);
  96. }
  97.  
  98. Object P_Nullp (x) Object x; {
  99.     return Nullp (x) ? True : False;
  100. }
  101.  
  102. Object P_Pairp (x) Object x; {
  103.     return TYPE(x) == T_Pair ? True : False;
  104. }
  105.  
  106. Object P_Listp (x) Object x; {
  107.     Object s;
  108.     register f;
  109.  
  110.     for (s = x, f = 0; !Nullp (x); f ^= 1) {
  111.     if (TYPE(x) != T_Pair)
  112.         return False;
  113.     if ((x = Cdr (x)) == s)
  114.         return False;
  115.     if (f) s = Cdr (s);
  116.     }
  117.     return True;
  118. }
  119.  
  120. Object P_Setcar (x, new) Object x, new; {
  121.     Check_Type (x, T_Pair);
  122.     Check_Mutable (x);
  123.     return Car (x) = new;
  124. }
  125.  
  126. Object P_Setcdr (x, new) Object x, new; {
  127.     Check_Type (x, T_Pair);
  128.     Check_Mutable (x);
  129.     return Cdr (x) = new;
  130. }
  131.  
  132. Object General_Member (key, list, comp) Object key, list; register comp; {
  133.     register r;
  134.  
  135.     for ( ; !Nullp (list); list = Cdr (list)) {
  136.     Check_List (list);
  137.     if (comp == 0)
  138.         r = EQ(Car (list), key);
  139.     else if (comp == 1)
  140.         r = Eqv (Car (list), key);
  141.     else
  142.         r = Equal (Car (list), key);
  143.     if (r) return list;
  144.     }
  145.     return False;
  146. }
  147.  
  148. Object P_Memq (key, list) Object key, list; {
  149.     return General_Member (key, list, 0);
  150. }
  151.  
  152. Object P_Memv (key, list) Object key, list; {
  153.     return General_Member (key, list, 1);
  154. }
  155.  
  156. Object P_Member (key, list) Object key, list; {
  157.     return General_Member (key, list, 2);
  158. }
  159.  
  160. Object General_Assoc (key, alist, comp) Object key, alist; register comp; {
  161.     Object elem;
  162.     register r;
  163.  
  164.     for ( ; !Nullp (alist); alist = Cdr (alist)) {
  165.     Check_List (alist);
  166.     elem = Car (alist);
  167.     if (TYPE(elem) != T_Pair)
  168.         continue;
  169.     if (comp == 0)
  170.         r = EQ(Car (elem), key);
  171.     else if (comp == 1)
  172.         r = Eqv (Car (elem), key);
  173.     else
  174.         r = Equal (Car (elem), key);
  175.     if (r) return elem;
  176.     }
  177.     return False;
  178. }
  179.  
  180. Object P_Assq (key, alist) Object key, alist; {
  181.     return General_Assoc (key, alist, 0);
  182. }
  183.  
  184. Object P_Assv (key, alist) Object key, alist; {
  185.     return General_Assoc (key, alist, 1);
  186. }
  187.  
  188. Object P_Assoc (key, alist) Object key, alist; {
  189.     return General_Assoc (key, alist, 2);
  190. }
  191.  
  192. /* Not used by the interpreter kernel (lint may complain).
  193.  */
  194. Fast_Length (list) Object list; {
  195.     Object tail;
  196.     register i;
  197.  
  198.     for (i = 0, tail = list; TYPE(tail) == T_Pair; tail = Cdr (tail), i++)
  199.     ;
  200.     return i;
  201. }
  202.  
  203. Object P_Length (list) Object list; {
  204.     Object tail;
  205.     register i;
  206.  
  207.     for (i = 0, tail = list; !Nullp (tail); tail = Cdr (tail), i++)
  208.     Check_List (tail);
  209.     return Make_Integer (i);
  210. }
  211.  
  212. Object P_Make_List (n, init) Object n, init; {
  213.     register len;
  214.     Object list;
  215.     GC_Node;
  216.  
  217.     if ((len = Get_Integer (n)) < 0)
  218.     Range_Error (n);
  219.     list = Null;
  220.     GC_Link (init);
  221.     while (len-- > 0)
  222.     list = Cons (init, list);
  223.     GC_Unlink;
  224.     return list;
  225. }
  226.  
  227. Object P_List (argc, argv) Object *argv; {
  228.     Object list, tail, cell;
  229.     GC_Node2;
  230.  
  231.     GC_Link2 (list, tail);
  232.     for (list = tail = Null; argc-- > 0; tail = cell) {
  233.     cell = Cons (*argv++, Null);
  234.     if (Nullp (list))
  235.         list = cell;
  236.     else
  237.         (void)P_Setcdr (tail, cell);
  238.     }
  239.     GC_Unlink;
  240.     return list;
  241. }
  242.  
  243. Object P_Last_Pair (x) Object x; {
  244.     Check_Type (x, T_Pair);
  245.     for ( ; TYPE(Cdr (x)) == T_Pair; x = Cdr (x)) ;
  246.     return x;
  247. }
  248.  
  249. Object P_Append (argc, argv) Object *argv; {
  250.     Object list, last, tail, cell;
  251.     register i;
  252.     GC_Node3;
  253.  
  254.     list = last = Null;
  255.     GC_Link3 (list, last, tail);
  256.     for (i = 0; i < argc-1; i++) {
  257.     for (tail = argv[i]; !Nullp (tail); tail = Cdr (tail)) {
  258.         Check_List (tail);
  259.         cell = Cons (Car (tail), Null);
  260.         if (Nullp (list))
  261.         list = cell;
  262.         else
  263.         (void)P_Setcdr (last, cell);
  264.         last = cell;
  265.     }
  266.     }
  267.     if (argc)
  268.     if (Nullp (list))
  269.         list = argv[i];
  270.     else
  271.         (void)P_Setcdr (last, argv[i]);
  272.     GC_Unlink;
  273.     return list;
  274. }
  275.  
  276. Object P_Append_Set (argc, argv) Object *argv; {
  277.     register i, j;
  278.  
  279.     for (i = j = 0; i < argc; i++)
  280.     if (!Nullp (argv[i]))
  281.         argv[j++] = argv[i];
  282.     if (j == 0)
  283.     return Null;
  284.     for (i = 0; i < j-1; i++)
  285.     (void)P_Setcdr (P_Last_Pair (argv[i]), argv[i+1]);
  286.     return *argv;
  287. }
  288.  
  289. Object P_Reverse (x) Object x; {
  290.     Object ret;
  291.     GC_Node;
  292.  
  293.     GC_Link (x);
  294.     for (ret = Null; !Nullp (x); x = Cdr (x)) {
  295.     Check_List (x);
  296.     ret = Cons (Car (x), ret);
  297.     }
  298.     GC_Unlink;
  299.     return ret;
  300. }
  301.  
  302. Object P_Reverse_Set (x) Object x; {
  303.     Object prev, tail;
  304.  
  305.     for (prev = Null; !Nullp (x); prev = x, x = tail) {
  306.     Check_List (x);
  307.     tail = Cdr (x);
  308.     (void)P_Setcdr (x, prev);
  309.     }
  310.     return prev;
  311. }
  312.  
  313. Object P_List_Tail (x, num) Object x, num; {
  314.     register n;
  315.  
  316.     for (n = Get_Integer (num); n > 0 && !Nullp (x); n--, x = P_Cdr (x)) ;
  317.     return x;
  318. }
  319.  
  320. Object P_List_Ref (x, num) Object x, num; {
  321.     return P_Car (P_List_Tail (x, num));
  322. }
  323.  
  324. Object Copy_List (x) Object x; {
  325.     Object car, cdr;
  326.     GC_Node3;
  327.  
  328.     if (TYPE(x) == T_Pair) {
  329.     if (Stack_Size () > Max_Stack)
  330.         Uncatchable_Error ("Out of stack space");
  331.     car = cdr = Null;
  332.     GC_Link3 (x, car, cdr);
  333.     car = Copy_List (Car (x));
  334.     cdr = Copy_List (Cdr (x));
  335.     x = Cons (car, cdr);
  336.     GC_Unlink;
  337.     }
  338.     return x;
  339. }
  340.